home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / nt / emacssrc.zip / EMACSSRC.TAR / emacs-19.17 / lisp / mhspool.el < prev    next >
Lisp/Scheme  |  1993-07-23  |  15KB  |  491 lines
  1. ;;; mhspool.el --- MH folder access using NNTP for GNU Emacs
  2.  
  3. ;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Maintainer: FSF
  7. ;; Keywords: mail, news
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; This package enables you to read mail or articles in MH folders, or
  28. ;; articles saved by GNUS. In any case, the file names of mail or
  29. ;; articles must consist of only numeric letters.
  30.  
  31. ;; Before using this package, you have to create a server specific
  32. ;; startup file according to the directory which you want to read. For
  33. ;; example, if you want to read mail under the directory named
  34. ;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is
  35. ;; no way to specify hierarchical directory now.) In this case, the
  36. ;; name of the NNTP server passed to GNUS must be `:Mail'.
  37.  
  38. ;;; Code:
  39.  
  40. (require 'nntp)
  41.  
  42. (defvar mhspool-list-folders-method
  43.   (function mhspool-list-folders-using-sh)
  44.   "*Function to list files in folders.
  45. The function should accept a directory as its argument, and fill the
  46. current buffer with file and directory names.  The output format must
  47. be the same as that of 'ls -R1'.  Two functions
  48. mhspool-list-folders-using-ls and mhspool-list-folders-using-sh are
  49. provided now.  I suppose the later is faster.")
  50.  
  51. (defvar mhspool-list-directory-switches '("-R")
  52.   "*Switches for mhspool-list-folders-using-ls to pass to `ls' for getting file lists.
  53. One entry should appear on one line. You may need to add `-1' option.")
  54.  
  55.  
  56.  
  57. (defconst mhspool-version "MHSPOOL 1.8"
  58.   "Version numbers of this version of MHSPOOL.")
  59.  
  60. (defvar mhspool-spool-directory "~/Mail"
  61.   "Private mail directory.")
  62.  
  63. (defvar mhspool-current-directory nil
  64.   "Current news group directory.")
  65.  
  66. ;;;
  67. ;;; Replacement of Extended Command for retrieving many headers.
  68. ;;;
  69.  
  70. (defun mhspool-retrieve-headers (sequence)
  71.   "Return list of article headers specified by SEQUENCE of article id.
  72. The format of list is
  73.  `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
  74. If there is no References: field, In-Reply-To: field is used instead.
  75. Reader macros for the vector are defined as `nntp-header-FIELD'.
  76. Writer macros for the vector are defined as `nntp-set-header-FIELD'.
  77. Newsgroup must be selected before calling this."
  78.   (save-excursion
  79.     (set-buffer nntp-server-buffer)
  80.     ;;(erase-buffer)
  81.     (let ((file nil)
  82.       (number (length sequence))
  83.       (count 0)
  84.       (headers nil)            ;Result list.
  85.       (article 0)
  86.       (subject nil)
  87.       (message-id nil)
  88.       (from nil)
  89.       (xref nil)
  90.       (lines 0)
  91.       (date nil)
  92.       (references nil))
  93.       (while sequence
  94.     ;;(nntp-send-strings-to-server "HEAD" (car sequence))
  95.     (setq article (car sequence))
  96.     (setq file
  97.           (concat mhspool-current-directory (prin1-to-string article)))
  98.     (if (and (file-exists-p file)
  99.          (not (file-directory-p file)))
  100.         (progn
  101.           (erase-buffer)
  102.           (insert-file-contents file)
  103.           ;; Make message body invisible.
  104.           (goto-char (point-min))
  105.           (search-forward "\n\n" nil 'move)
  106.           (narrow-to-region (point-min) (point))
  107.           ;; Fold continuation lines.
  108.           (goto-char (point-min))
  109.           (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
  110.         (replace-match " " t t))
  111.           ;; Make it possible to search for `\nFIELD'.
  112.           (goto-char (point-min))
  113.           (insert "\n")
  114.           ;; Extract From:
  115.           (goto-char (point-min))
  116.           (if (search-forward "\nFrom: " nil t)
  117.           (setq from (buffer-substring
  118.                   (point)
  119.                   (save-excursion (end-of-line) (point))))
  120.         (setq from "(Unknown User)"))
  121.           ;; Extract Subject:
  122.           (goto-char (point-min))
  123.           (if (search-forward "\nSubject: " nil t)
  124.           (setq subject (buffer-substring
  125.                  (point)
  126.                  (save-excursion (end-of-line) (point))))
  127.         (setq subject "(None)"))
  128.           ;; Extract Message-ID:
  129.           (goto-char (point-min))
  130.           (if (search-forward "\nMessage-ID: " nil t)
  131.           (setq message-id (buffer-substring
  132.                     (point)
  133.                     (save-excursion (end-of-line) (point))))
  134.         (setq message-id nil))
  135.           ;; Extract Date:
  136.           (goto-char (point-min))
  137.           (if (search-forward "\nDate: " nil t)
  138.           (setq date (buffer-substring
  139.                   (point)
  140.                   (save-excursion (end-of-line) (point))))
  141.         (setq date nil))
  142.           ;; Extract Lines:
  143.           (goto-char (point-min))
  144.           (if (search-forward "\nLines: " nil t)
  145.           (setq lines (string-to-int
  146.                    (buffer-substring
  147.                 (point)
  148.                 (save-excursion (end-of-line) (point)))))
  149.         ;; Count lines since there is no lines field in most cases.
  150.         (setq lines
  151.               (save-restriction
  152.             (goto-char (point-max))
  153.             (widen)
  154.             (count-lines (point) (point-max)))))
  155.           ;; Extract Xref:
  156.           (goto-char (point-min))
  157.           (if (search-forward "\nXref: " nil t)
  158.           (setq xref (buffer-substring
  159.                   (point)
  160.                   (save-excursion (end-of-line) (point))))
  161.         (setq xref nil))
  162.           ;; Extract References:
  163.           ;; If no References: field, use In-Reply-To: field instead.
  164.           ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA).
  165.           (goto-char (point-min))
  166.           (if (or (search-forward "\nReferences: " nil t)
  167.               (search-forward "\nIn-Reply-To: " nil t))
  168.           (setq references (buffer-substring
  169.                     (point)
  170.                     (save-excursion (end-of-line) (point))))
  171.         (setq references nil))
  172.           ;; Collect valid article only.
  173.           (and article
  174.            message-id
  175.            (setq headers
  176.              (cons (vector article subject from
  177.                        xref lines date
  178.                        message-id references) headers)))
  179.           ))
  180.     (setq sequence (cdr sequence))
  181.     (setq count (1+ count))
  182.     (and (numberp nntp-large-newsgroup)
  183.          (> number nntp-large-newsgroup)
  184.          (zerop (% count 20))
  185.          (message "MHSPOOL: Receiving headers... %d%%"
  186.               (/ (* count 100) number)))
  187.     )
  188.       (and (numberp nntp-large-newsgroup)
  189.        (> number nntp-large-newsgroup)
  190.        (message "MHSPOOL: Receiving headers... done"))
  191.       (nreverse headers)
  192.       )))
  193.  
  194.  
  195. ;;;
  196. ;;; Replacement of NNTP Raw Interface.
  197. ;;;
  198.  
  199. (defun mhspool-open-server (host &optional service)
  200.   "Open news server on HOST.
  201. If HOST is nil, use value of environment variable `NNTPSERVER'.
  202. If optional argument SERVICE is non-nil, open by the service name."
  203.   (let ((host (or host (getenv "NNTPSERVER")))
  204.     (status nil))
  205.     ;; Get directory name from HOST name.
  206.     (if (string-match ":\\(.+\\)$" host)
  207.     (progn
  208.       (setq mhspool-spool-directory
  209.         (file-name-as-directory
  210.          (expand-file-name
  211.           (substring host (match-beginning 1) (match-end 1))
  212.           (expand-file-name "~/" nil))))
  213.       (setq host (system-name)))
  214.       (setq mhspool-spool-directory nil))
  215.     (setq nntp-status-string "")
  216.     (cond ((and (stringp host)
  217.         (stringp mhspool-spool-directory)
  218.         (file-directory-p mhspool-spool-directory)
  219.         (string-equal host (system-name)))
  220.        (setq status (mhspool-open-server-internal host service)))
  221.       ((string-equal host (system-name))
  222.        (setq nntp-status-string
  223.          (format "No such directory: %s.  Goodbye."
  224.              mhspool-spool-directory)))
  225.       ((null host)
  226.        (setq nntp-status-string "NNTP server is not specified."))
  227.       (t
  228.        (setq nntp-status-string
  229.          (format "MHSPOOL: cannot talk to %s." host)))
  230.       )
  231.     status
  232.     ))
  233.  
  234. (defun mhspool-close-server ()
  235.   "Close news server."
  236.   (mhspool-close-server-internal))
  237.  
  238. (fset 'mhspool-request-quit (symbol-function 'mhspool-close-server))
  239.  
  240. (defun mhspool-server-opened ()
  241.   "Return server process status, T or NIL.
  242. If the stream is opened, return T, otherwise return NIL."
  243.   (and nntp-server-buffer
  244.        (get-buffer nntp-server-buffer)))
  245.  
  246. (defun mhspool-status-message ()
  247.   "Return server status response as string."
  248.   nntp-status-string
  249.   )
  250.  
  251. (defun mhspool-request-article (id)
  252.   "Select article by message ID (or number)."
  253.   (let ((file (concat mhspool-current-directory (prin1-to-string id))))
  254.     (if (and (stringp file)
  255.          (file-exists-p file)
  256.          (not (file-directory-p file)))
  257.     (save-excursion
  258.       (mhspool-find-file file)))
  259.     ))
  260.  
  261. (defun mhspool-request-body (id)
  262.   "Select article body by message ID (or number)."
  263.   (if (mhspool-request-article id)
  264.       (save-excursion
  265.     (set-buffer nntp-server-buffer)
  266.     (goto-char (point-min))
  267.     (if (search-forward "\n\n" nil t)
  268.         (delete-region (point-min) (point)))
  269.     t
  270.     )
  271.     ))
  272.  
  273. (defun mhspool-request-head (id)
  274.   "Select article head by message ID (or number)."
  275.   (if (mhspool-request-article id)
  276.       (save-excursion
  277.     (set-buffer nntp-server-buffer)
  278.     (goto-char (point-min))
  279.     (if (search-forward "\n\n" nil t)
  280.         (delete-region (1- (point)) (point-max)))
  281.     t
  282.     )
  283.     ))
  284.  
  285. (defun mhspool-request-stat (id)
  286.   "Select article by message ID (or number)."
  287.   (setq nntp-status-string "MHSPOOL: STAT is not implemented.")
  288.   nil
  289.   )
  290.  
  291. (defun mhspool-request-group (group)
  292.   "Select news GROUP."
  293.   (cond ((file-directory-p
  294.       (mhspool-article-pathname group))
  295.      ;; Mail/NEWS.GROUP/N
  296.      (setq mhspool-current-directory
  297.            (mhspool-article-pathname group)))
  298.     ((file-directory-p
  299.       (mhspool-article-pathname
  300.        (mhspool-replace-chars-in-string group ?. ?/)))
  301.      ;; Mail/NEWS/GROUP/N
  302.      (setq mhspool-current-directory
  303.            (mhspool-article-pathname
  304.         (mhspool-replace-chars-in-string group ?. ?/))))
  305.     ))
  306.  
  307. (defun mhspool-request-list ()
  308.   "List active newsgoups."
  309.   (save-excursion
  310.     (let* ((newsgroup nil)
  311.        (articles nil)
  312.        (directory (file-name-as-directory
  313.                (expand-file-name mhspool-spool-directory nil)))
  314.        (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$"))
  315.        (buffer (get-buffer-create " *MHSPOOL File List*")))
  316.       (set-buffer nntp-server-buffer)
  317.       (erase-buffer)
  318.       (set-buffer buffer)
  319.       (erase-buffer)
  320. ;;      (apply 'call-process
  321. ;;         "ls" nil t nil
  322. ;;         (append mhspool-list-directory-switches (list directory)))
  323.       (funcall mhspool-list-folders-method directory)
  324.       (goto-char (point-min))
  325.       (while (re-search-forward folder-regexp nil t)
  326.     (setq newsgroup
  327.           (mhspool-replace-chars-in-string
  328.            (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.))
  329.     (setq articles nil)
  330.     (forward-line 1)        ;(beginning-of-line)
  331.     ;; Thank nobu@flab.fujitsu.junet for his bug fixes.
  332.     (while (and (not (eobp))
  333.             (not (looking-at "^$")))
  334.       (if (looking-at "^[0-9]+$")
  335.           (setq articles
  336.             (cons (string-to-int
  337.                (buffer-substring
  338.                 (match-beginning 0) (match-end 0)))
  339.               articles)))
  340.       (forward-line 1))
  341.     (if articles
  342.         (princ (format "%s %d %d n\n" newsgroup
  343.                (apply (function max) articles)
  344.                (apply (function min) articles))
  345.            nntp-server-buffer))
  346.     )
  347.       (kill-buffer buffer)
  348.       (set-buffer nntp-server-buffer)
  349.       (buffer-size)
  350.       )))
  351.  
  352. (defun mhspool-request-list-newsgroups ()
  353.   "List newsgoups (defined in NNTP2)."
  354.   (setq nntp-status-string "MHSPOOL: LIST NEWSGROUPS is not implemented.")
  355.   nil
  356.   )
  357.  
  358. (defun mhspool-request-list-distributions ()
  359.   "List distributions (defined in NNTP2)."
  360.   (setq nntp-status-string "MHSPOOL: LIST DISTRIBUTIONS is not implemented.")
  361.   nil
  362.   )
  363.  
  364. (defun mhspool-request-last ()
  365.   "Set current article pointer to the previous article
  366. in the current news group."
  367.   (setq nntp-status-string "MHSPOOL: LAST is not implemented.")
  368.   nil
  369.   )
  370.  
  371. (defun mhspool-request-next ()
  372.   "Advance current article pointer."
  373.   (setq nntp-status-string "MHSPOOL: NEXT is not implemented.")
  374.   nil
  375.   )
  376.  
  377. (defun mhspool-request-post ()
  378.   "Post a new news in current buffer."
  379.   (setq nntp-status-string "MHSPOOL: POST: what do you mean?")
  380.   nil
  381.   )
  382.  
  383.  
  384. ;;;
  385. ;;; Replacement of Low-Level Interface to NNTP Server.
  386. ;;; 
  387.  
  388. (defun mhspool-open-server-internal (host &optional service)
  389.   "Open connection to news server on HOST by SERVICE (default is nntp)."
  390.   (save-excursion
  391.     (if (not (string-equal host (system-name)))
  392.     (error "MHSPOOL: cannot talk to %s." host))
  393.     ;; Initialize communication buffer.
  394.     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
  395.     (set-buffer nntp-server-buffer)
  396.     (buffer-flush-undo (current-buffer))
  397.     (erase-buffer)
  398.     (kill-all-local-variables)
  399.     (setq case-fold-search t)        ;Should ignore case.
  400.     (setq nntp-server-process nil)
  401.     (setq nntp-server-name host)
  402.     ;; It is possible to change kanji-fileio-code in this hook.
  403.     (run-hooks 'nntp-server-hook)
  404.     t
  405.     ))
  406.  
  407. (defun mhspool-close-server-internal ()
  408.   "Close connection to news server."
  409.   (if nntp-server-buffer
  410.       (kill-buffer nntp-server-buffer))
  411.   (setq nntp-server-buffer nil)
  412.   (setq nntp-server-process nil))
  413.  
  414. (defun mhspool-find-file (file)
  415.   "Insert FILE in server buffer safely."
  416.   (set-buffer nntp-server-buffer)
  417.   (erase-buffer)
  418.   (condition-case ()
  419.       (progn
  420.     (insert-file-contents file)
  421.     (goto-char (point-min))
  422.     ;; If there is no body, `^L' appears at end of file. Special
  423.     ;; hack for MH folder.
  424.     (and (search-forward "\n\n" nil t)
  425.          (string-equal (buffer-substring (point) (point-max)) "\^L")
  426.          (delete-char 1))
  427.     t
  428.     )
  429.     (file-error nil)
  430.     ))
  431.  
  432. (defun mhspool-article-pathname (group)
  433.   "Make pathname for GROUP."
  434.   (concat (file-name-as-directory mhspool-spool-directory) group "/"))
  435.  
  436. (defun mhspool-replace-chars-in-string (string from to)
  437.   "Replace characters in STRING from FROM to TO."
  438.   (let ((string (substring string 0))    ;Copy string.
  439.     (len (length string))
  440.     (idx 0))
  441.     ;; Replace all occurrences of FROM with TO.
  442.     (while (< idx len)
  443.       (if (= (aref string idx) from)
  444.       (aset string idx to))
  445.       (setq idx (1+ idx)))
  446.     string
  447.     ))
  448.  
  449.  
  450. ;; Methods for listing files in folders.
  451.  
  452. (defun mhspool-list-folders-using-ls (directory)
  453.   "List files in folders under DIRECTORY using 'ls'."
  454.   (apply 'call-process
  455.      "ls" nil t nil
  456.      (append mhspool-list-directory-switches (list directory))))
  457.  
  458. ;; Basic ideas by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA)
  459.  
  460. (defun mhspool-list-folders-using-sh (directory)
  461.   "List files in folders under DIRECTORY using '/bin/sh'."
  462.   (let ((buffer (current-buffer))
  463.     (script (get-buffer-create " *MHSPOOL Shell Script Buffer*")))
  464.     (save-excursion
  465.       (save-restriction
  466.     (set-buffer script)
  467.     (erase-buffer)
  468.     ;; /bin/sh script which does 'ls -R'.
  469.     (insert
  470.      "PS2=
  471.           ffind() {
  472.         cd $1; echo $1:
  473.         ls -1
  474.         echo
  475.         for j in `echo *[a-zA-Z]*`
  476.         do
  477.           if [ -d $1/$j ]; then
  478.             ffind $1/$j
  479.           fi
  480.         done
  481.       }
  482.       cd " directory "; ffind `pwd`; exit 0\n")
  483.     (call-process-region (point-min) (point-max) "sh" nil buffer nil)
  484.     ))
  485.     (kill-buffer script)
  486.     ))
  487.  
  488. (provide 'mhspool)
  489.  
  490. ;;; mhspool.el ends here
  491.